perm filename SETF[MAC,LSP] blob
sn#579634 filedate 1981-04-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00007 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SETF -*-MODE:LISPPACKAGE:SI-*- -*-LISP-*-
C00006 00003
C00012 00004
C00018 00005
C00023 00006
C00028 00007
C00036 ENDMK
C⊗;
;;; SETF -*-MODE:LISP;PACKAGE:SI-*- -*-LISP-*-
;;; **************************************************************
;;; ***** NIL ******** SETF, PUSH, and POP Expanders ************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
(eval-when (eval compile)
(cond ((and (status feature MACLISP) (status nofeature FOR-NIL))
(sstatus feature FM)
(sstatus feature FOR-MACLISP)))
)
(herald SETF /286)
#+FM
(eval-when (compile)
(mapc '(lambda (x) (putprop x 'T 'SKIP-WARNING))
'(SETF +INTERNAL-SETF-X +INTERNAL-SETF-X-1 SETF-SIMPLEP-SCAN
+INTERNAL-CARCDR-SETF +INTERNAL-PUSH-X +INTERNAL-POP-X
DEFUPDATE PUSH POP))
)
#-FM
(globalize "+INTERNAL-SETF-X" "+INTERNAL-POP-X" "+INTERNAL-SETF-X-1"
"+INTERNAL-PUSH-X" "+INTERNAL-CARCDR-SETF" "SETF-SIMPLEP-SCAN"
"SETF-STRUCT" "SETF" "DEFUPDATE")
;;; Current contents:
;;; Functions: +INTERNAL-SETF-X, +INTERNAL-SETF-X-1, +INTERNAL-CARCDR-SETF
;;; +INTERNAL-PUSH-X, +INTERNAL-POP-X, DEFUPDATE
;;; and defsetfs for various functions
#-For-NIL
(eval-when (eval compile)
(macro lispdir (x)
(setq x (cadr x))
#+Pdp10 `(QUOTE ((LISP) ,x FASL))
#+Lispm (string-append "lisp;" (get-pname x) "qfasl")
#+Multics (catenate ">exl>lisp←dir>object" (get←pname x))
#+For-NIL (string-append "lisp:" (get-pname x) "vasl")
)
)
#-For-NIL
(eval-when (eval compile)
(macro subload (x)
(setq x (cadr x))
`(OR (GET ',x 'VERSION) (LOAD #%(LISPDIR ,x))))
(subload MACAID)
;; Following will also load VECTOR and DEFVST at eval-compile times
(subload EXTMAC)
(subload EXTEND)
(subload DEFSETF)
(subload EVONCE)
)
(declare (*expr EVAL-ORDERED*))
;;;; Comments
;; There are problems with doing PUSH and POP regarding multiple evaluations
;; of the computation yielding the stack. Simply expanding into SETF
;; results in unobvious order-of-evaluation and multiple evaluation, and
;; the wrong return result.
;; To deal with this, we interrupt the SETF expansion midway, after all
;; the pieces have been picked apart. The setf expanders for the various
;; functions provide us with a structure containing the computations required,
;; the value to be stored, and continuation functions to apply to the
;; computations to get the forms to store and retrieve the value. This lets
;; us substitute gensyms for computations that we decide should not be repeated
;; and lambda-bind the gensyms to the computations.
;; The components of the setf-struct are as follows
;; * SETF-compute A list (who's length we'll call "n")
;; of forms to be EVAL'ed in the
;; computation prior to storing the
;; value.
;; SETF-i-compute A copy of the initial value of
;; SETF-compute
;; SETF-side-effects A flag, non-null if SETF-SIMPLEP-SCAN
;; encountered any expressions which may
;; have contained side effects.
;; Initially ().
;; * SETF-access A function of n arguments, to be APPLYd
;; to the applied to the computations
;; to give a form to access the
;; specified slot of the structure
;; given the computations with whatever
;; gensym substitutions performed.
;; * SETF-invert A function of n+1 arguments, to be
;; applied to SETF-allcomps
;; * SETF-ret-ok A flag, non-null implies form returned
;; by SETF-invert will be the value of
;; the SETF-value-expr
;; SETF-genvals A list of values for which gensyms have
;; been substituted for in SETF-compute.
;; SETF-gensyms A list of gensyms, one-to-one with
;; values in SETF-genvals
;; SETF-user-slot A slot available for communication
;; between SETF-X expanders and their
;; continuations (INVERT and ACCESS)
;; These objects are returned by +INTERNAL-SETF-X-1. They are updated by
;; SETF-SIMPLEP-SCAN to build the SETF-genvals and SETF-gensyms slots, from
;; which a lambda form can be wrapped around the accessing and setting.
;; The user of the structure is responsible for remembering the value to
;; be stored, and possibly substituting a gensym for it in the lambda form.
;; The slots marked above with a "*" are supplied by calling the SETF-X
;; property on the X part of (SETF X Y). (the case of X being a symbol
;; is special-cased, and the CAR/CDR cases are handled specially if no
;; SETF property is found.)
;; (SETF-STRUCT access invert ret-ok compute)
;; creates one of these SETF structures. The value component is
;; Note: The variable EFFS herein is not special. It is, however, equivalent
;; in function to the compiler's (NCOMPLR and LCP) variable EFFS. If non-(),
;; the form is being expanded "for effect", i.e. the return value is going to b
;; ignored, so don't bother taking pains to preserve it. It is supplied as ()
;; in the interpreter, and currently in the compiler as well.
;; +INTERNAL-PUSH-X and +INTERNAL-POP-X are called by the interpreter and
;; compiler to expand complex PUSH and POPs. The first argument is the
;; CDR of the PUSH or POP form (viewed as a macro, or the entire argument
;; to the PUSH or POP FSUBR in the interpreter). The second is the
;; EFFS argument as above.
;; (DEFMACRO PUSH (&REST PUSH-ARGS) `(+INTERNAL-PUSH-X ,PUSH-ARGS () ))
;; (DEFMACRO POP (&REST POP-ARGS) `(+INTERNAL-POP-X ,POP-ARGS () ))
;;;; +INTERNAL-PUSH-X and +INTERNAL-POP-X
(defmacro defupdate (name conser)
`(defmacro ,name (&whole form)
(+internal-push-x (cdr form)
() ;Losing compiler doesn't hack EFFS
;at macro-expansion time.
',conser)))
;; example: (defupdate PUSH CONS)
;; (defupdate accumulate PLUS)
;; (defmacro increment (x) `(accumulate 1 ,x))
(defun +INTERNAL-PUSH-X ((val stack) effs &optional (push-cons 'cons)
&aux valval valsym temp)
(let ((expf-stack (setf-simplep-scan (+internal-setf-x-1 stack) ())))
(cond ((and (not (|constant-p/|| val))
(not (null (SETF-gensyms expf-stack))))
(setq valval (ncons val))
(setq valsym (ncons (setq val (gensym))))))
(cond ((or effs (SETF-ret-ok expf-stack))
(setq temp
(setf-invert-form expf-stack
`(,push-cons ,val
,(setf-access-form expf-stack)))))
('T (let ((tsym (gensym)))
(setq temp
`((lambda (,tsym)
,(setf-invert-form expf-stack tsym)
,tsym)
(,push-cons ,val
,(setf-access-form expf-stack)))))))
(cond ((null (SETF-gensyms expf-stack)) temp)
('T `((lambda (,@valsym ,.(SETF-gensyms expf-stack))
,temp)
,.valval ,.(SETF-genvals expf-stack))))))
;; POP must be careful of side-effect interactions between first and second arg
(defun +INTERNAL-POP-X ((stack . into) effs
&optional
(pop-car 'car)
(pop-cdr 'cdr)
)
(let ((expf-stack (setf-simplep-scan (+internal-setf-x-1 stack) ()))
(stack-access-form) (temp)
(expf-into (and (not (null into)) (+internal-setf-x-1 (car into)))))
(cond (into
(setf-simplep-scan expf-into (setf-side-effects expf-stack))))
(cond ((or (not (null (SETF-gensyms expf-stack)))
(and into (SETF-side-effects expf-into)))
(let ((tsym (gensym)))
(setq temp `((car ,tsym)))
(cond ((and (not effs) ;Maybe save ret value
(not (SETF-ret-ok expf-into)))
(setq temp `((setq ,tsym ,@temp)))))
(cond (into
(cond ((and (setf-side-effects expf-into)
(not (setf-side-effects expf-stack)))
(setf-simplep-scan expf-stack T)))
(setq temp
(ncons (setf-invert-form expf-into (car temp))))))
(cond ((and (not effs)
(not (SETF-ret-ok expf-into))) ;Maybe need ret value
(setq temp `(,@temp ,tsym))))
`((lambda (,.(SETF-gensyms expf-stack)
,.(and into (SETF-gensyms expf-into)))
((lambda (,tsym)
,(setf-invert-form expf-stack `(,pop-cdr ,tsym))
,@temp)
,(setf-access-form expf-stack)))
,.(SETF-genvals expf-stack)
,.(and into (SETF-genvals expf-into)))))
((+internal-dup-p
(setq stack-access-form (setf-access-form expf-stack)))
(setq temp `(,pop-car ,stack-access-form))
(cond ((not (null into)) ;Better code with SETQ inside PROG2
(setq temp
(+internal-setf-x `(,(car into) ,temp) effs))))
`(prog2 () ,temp
,(setf-invert-form expf-stack `(,pop-cdr ,stack-access-form))))
('T (let ((tsym (gensym)))
(setq temp
`((lambda (,tsym)
,(setf-invert-form expf-stack `(,pop-cdr ,tsym))
(,pop-car ,tsym))
,stack-access-form)))
(cond ((not (null into))
(+internal-setf-x `(,(car into) ,temp) effs))
('T temp))))))
;;;; SETF macro, +INTERNAL-SETF-X, and SETF-SIMPLEP-SCAN
(defmacro SETF (&rest w) (+internal-setf-x w () ))
(defun +INTERNAL-SETF-X (w effs)
(do ((l w (cddr l))
(form) (val) (expf) (val-gensym) (ret-form))
((null l)
(cond ((null (cdr ret-form)) (car ret-form))
('T `(PROGN ,. (nreverse ret-form)))))
;One step in expanding "(SETF ... form val ... )"
(desetq (form val) l)
(if (null (cdr l))
(setq val (cerror T () ':WRONG-NUMBER-OF-ARGUMENTS
"SETF called with an odd number of arguments. }@
Extra reference = }3G}S.}@
Supply a form to evaluate, store and return."
'SETF (length w) w form)))
(setq expf (+INTERNAL-SETF-X-1 form))
(cond ((or (and (null (cddr l)) ;If at end of SETF
(not effs) ;If values matter at all
(not (SETF-ret-ok expf)) ;If it wrong val at end
(not (+internal-dup-p val))) ;And we can't duplicate
(not (equal (SETF-compute expf) ;If already simplified
(SETF-i-compute expf))))
(if (equal (SETF-compute expf)
(SETF-i-compute expf))
(setf-simplep-scan expf ()))
(setq val-gensym (gensym))
(setq ret-form
(cons `((lambda (,@(SETF-gensyms expf) ,val-gensym)
,(setf-invert-form expf val-gensym)
,val-gensym)
,@(SETF-genvals expf) ,val)
ret-form)))
('T (setq ret-form (cons (setf-invert-form expf val)
ret-form))
(cond ((and (not effs)
(not (cddr l))
(not (SETF-ret-ok expf)))
(setq ret-form (cons val ret-form))))))))
;; Call SETF-SIMPLEP-SCAN on a SETF-STRUCT, and a second arg saying whether
;; or not side effects have been detected.
;; NO-OP if SETF-SIMPLEP-SCAN already called on it.
(defun SETF-SIMPLEP-SCAN (expf constantp)
(if (null (SETF-gensyms expf))
(let ((rest (SETF-compute expf)))
(do ((clist () (cond ((not (null sitem)) (cons citem clist))
('T clist)))
(slist () (cond ((not (null sitem)) (cons sitem slist))
('T slist)))
(rest rest (cdr rest))
(sitem () ())
(citem))
((null rest) (SSETF-genvals expf (nreverse clist))
(SSETF-gensyms expf (nreverse slist)))
(rplaca rest (macroexpand (car rest)))
(cond ((|constant-p/|| (car rest))) ;Always safe!
((and (not constantp)
(|side-effectsp/|| (car rest))) ;side-effects
(SSETF-compute expf ;all is in
(append (SETF-I-compute expf) ())) ;so reset and
(SSETF-side-effects expf T) ;carefully
(return (setf-simplep-scan expf T))) ;do it again!
((and (not constantp) (+internal-dup-p (car rest))))
('T (setq citem (car rest))
(rplaca rest (setq sitem (gensym))))))))
expf)
;;;; +INTERNAL-SETF-X-1 and +INTERNAL-CARCDR-SETF
;; +INTERNAL-SETF-X-1 takes an access expression and returns a SETF-STRUCT
;; which contains the various info documented at the head of this file.
;; The way the expansion happens is a loop of the following:
;; a) If it's a symbol, special case
;; b) If the CAR is a symbol, and has a SETF-X property, FUNCALL it on the
;; access and value expressions (unless that property is 'AUTOLOAD',
;; meaning that autoloading should be tried if possible, or if it is
;; 'SETF-X' meaning autoloading has been tried and lost).
;; c) If it's a macro, MACROEXPAND-1 it and return
(defun +INTERNAL-SETF-X-1 (expr)
(prog (temp oper)
A (cond ((atom expr)
(cond ((symbolp expr)
(return (SETF-STRUCT `(LAMBDA (()) ',expr)
`(lambda (() y) `(setq ,',expr ,y))
'T
() )))))
((not (symbolp (setq oper (car expr)))) () )
((and (setq temp (get oper 'SETF-X))
(not (memq temp '(AUTOLOAD SETF-X))))
(return (funcall temp expr)))
('T (cond ((and (cond ((null temp)
;;This excludes carcdrs ??
(not (fboundp oper)))
((eq temp 'AUTOLOAD))) ;Help for LDB etc
(setq temp (get oper 'AUTOLOAD)))
(funcall autoload `(,oper . ,temp))
(cond ((setq temp (get oper 'SETF-X))
(return (funcall temp expr)))
('T (putprop oper 'SETF-X 'SETF-X))))
((setq temp (macroexpand-1* expr))
;allow macro-redefinition, even for carcdr functions
(return (+INTERNAL-SETF-X-1 (car temp))))
((setq temp (|carcdrp/|| oper))
(return (+INTERNAL-carcdr-setf temp expr))))))
(setq expr (error '|Obscure format - SETF| expr 'WRNG-TYPE-ARG))
(go A)
))
(defun +INTERNAL-CARCDR-SETF (carcdrspec expr)
(let ((rplac (cond ((eq (car carcdrspec) 'A) 'rplaca)
('T 'rplacd)) )
(op (cond ((eq (car carcdrspec) 'A) 'CAR)
('T 'CDR)))
(carcdr (cadr carcdrspec) )
((() pair) expr)
(subform) )
(setq subform (cond ((or (null carcdr) (eq carcdr 'CR)) pair)
('T `(,carcdr ,pair))))
(SETF-STRUCT `(LAMBDA (() X) `(,',op ,x))
`(LAMBDA (() VALUE PAIR) `(,',rplac ,pair ,value))
()
`(,subform))))
(defun setf-invert-form (expf val)
(apply (SETF-invert expf)
`(,expf ,val ,@(SETF-compute expf))))
(defun setf-access-form (expf)
(apply (SETF-access expf)
`(,expf ,@(SETF-compute expf))))
; SETF-STRUCT is a slight variant on the constructor function
(defun SETF-STRUCT (access invert ret-ok compute)
(CONS-A-SETF COMPUTE compute
I-COMPUTE (APPEND compute ())
RET-OK ret-ok
ACCESS access
INVERT invert))
;;;; DEFSETFs for various system functions
(defsetf CXR ((() index frob) value) ()
`(RPLACX ,index ,frob ,value))
(defsetf NTH ((() index frob) value) ()
`(RPLACA (NTHCDR ,index ,frob) ,value))
(defsetf NTHCDR ((() index frob) value) ()
`(RPLACD (NTHCDR (1- ,index) ,frob) ,value))
;; The PROGN stuff isn't optimal, it will generate LAMBDAs unnecessarily.
;; Hopefully the compiler will eliminate them.
(defun (progn SETF-X) (expr)
(let* ((fun (car expr))
(temp (reverse (cdr expr)))
(frobref (car temp))
(steps (nreverse (cdr temp)))
(expf (setf-simplep-scan
(setf-struct (get 'progn 'SETF-X-ACCESS)
(get 'progn 'SETF-X-INVERT)
() steps)
() ))
(expf-frobref (setf-simplep-scan (+internal-setf-x-1 frobref) () )))
(SSETF-user-slot expf (list* fun expf-frobref))
(SSETF-genvals expf (append (SETF-genvals expf)
(SETF-genvals expf-frobref)))
(SSETF-gensyms expf (append (SETF-gensyms expf)
(SETF-gensyms expf-frobref)))
(SSETF-ret-ok expf (SETF-ret-ok expf-frobref))
expf))
(defun (progn SETF-X-ACCESS) (expf &rest steps)
#N (setq steps (to-list steps))
(let (( (fun . expf-frobref) (setf-user-slot expf)))
(if (and (null steps) (get fun 'setf-prognp))
(setf-access-form expf-frobref)
`(,fun ,@steps ,(setf-access-form expf-frobref)))))
(defun (progn SETF-X-INVERT) (expf val &rest steps)
#N (setq steps (to-list steps))
(let* (( (fun . expf-frobref) (setf-user-slot expf)))
(if (and (null steps) (get fun 'setf-prognp))
(setf-invert-form expf-frobref val)
`(,fun ,@steps ,(setf-invert-form expf-frobref val)))))
(defprop progn T setf-prognp)
(mapc #'(lambda (x)
(putprop x (get 'progn 'setf-x) 'setf-x))
'(FIXNUM-IDENTITY FLONUM-IDENTITY))
(defun (arraycall SETF-X) (g)
(let* (( (() type . frobs) g)
(struct (setf-struct (get 'ARRAYCALL 'SETF-X-ACCESS)
(get 'ARRAYCALL 'SETF-X-INVERT)
T frobs)))
(SSETF-user-slot struct type)
struct))
(defun (arraycall SETF-X-ACCESS) (expf array &rest indices)
#+For-NIL (setq indices (to-list indices))
`(ARRAYCALL ,(SETF-user-slot expf) ,array ,. indices))
(defun (arraycall SETF-X-INVERT) (expf val array &rest indices)
#+For-NIL (setq indices (to-list indices))
(let ((gensyms (mapcar #'(lambda (() ) (gensym)) indices)))
(eval-ordered* `(arraysym ,@gensyms valsym)
`(,array ,@indices ,val)
``((store (arraycall ,',(SETF-user-slot expf)
,arraysym
,,@gensyms)
,valsym)))))
(defsetf GET ((() sym tag) value) T
(eval-ordered* '(nsym ntag nvalue)
`(,sym ,tag ,value)
'`((PUTPROP ,nsym ,nvalue ,ntag))))
(defsetf PLIST ((() sym) value) T
`(SETPLIST ,sym ,value))
(defsetf SYMEVAL ((() sym) value) T
`(SET ,sym ,value))
(defsetf ARG ((() argument) value) T
`(SETARG ,argument ,value))
(defsetf ARGS ((() argument) value) ()
`(ARGS ,argument ,value))
(defsetf SFA-GET ((() sfa loc) value) T
`(SFA-STORE ,sfa ,loc ,value))
(defsetf LDB ((() byte word) value) ()
(si:ldb-dpb-stfx word byte () value '(DPB . T)))
(defsetf LOAD-BYTE ((() word position size) value) ()
(si:ldb-dpb-stfx word position size value '(DEPOSIT-BYTE . () )))
#+FM (progn 'compile
(defsetf *LDB ((() byte word) value) ()
(si:ldb-dpb-stfx word byte () value '(*DPB . T)))
(defsetf *LOAD-BYTE ((() word position size) value) ()
(si:ldb-dpb-stfx word position size value '(*DEPOSIT-BYTE . () )))
) ;end of #+FM
(defun SI:LDB-DPB-STFX (word position size value foo)
(let ((dpber (car foo)) ;like *DPB or DEPOSIT-BYTE or ...
(ppssp (cdr foo)) ;non-null iff LDB/DPB rather than LOAD-BYTE/...
(byte position) ;in the LDB case (as opposed to LOAD-BYTE)
(expf (+internal-setf-x-1 word))
side-effects valq valb byteq byteb)
(SETF-simplep-scan expf () )
(cond ((null ppssp) () )
((or (SETF-side-effects expf)
(|side-effectsp/|| value)
(|side-effectsp/|| byte))
(cond ((|constant-p/|| value))
('T (si:gen-local-var valq)
(setq valq (list valq) valb (list value)
value (car valq) side-effects 'T)))
(cond ((|constant-p/|| byte))
('T (si:gen-local-var byteq)
(setq byteq (list byteq) byteb (list byte)
byte (car byteq) side-effects 'T)))))
(let* ((access (setf-access-form expf))
(invert (setf-invert-form
expf
(if ppssp
`(,DPBer ,value ,byte ,access)
`(,DPBer ,access ,position ,size ,value)))))
(cond ((or side-effects (not (null (SETF-gensyms expf))))
`((LAMBDA (,.byteq ,@(SETF-gensyms expf) ,.valq)
,invert)
,.byteb ,@(SETF-genvals expf) ,.valb))
('T invert)))))
#-For-NIL (defprop EVAL-ORDERED* #.(lispdir evonce) AUTOLOAD)
ββ